Technotools/Technotools (Chestnut CD-ROM)(1993).ISO/unix/extar10/extar.pas

Pascal/Delphi Source File | 1990-02-26 | 10.0 KB | 305 lines

Program extar;
{ Extract from TAR file, correcting names to be acceptable for MS-DOS        }
{ No checking performed.                                                     }
{ FreeWare by TapirSoft Gisbert W.Selke, Feb 1990                            }
{$A+,B-,D+,E+,F-,I-,L+,N-,O-,R-,S+,V- }
{$M 16384,0,16384 }

  Uses Dos;

  Const progname = 'ExTAR';
        version = '1.0';
        copyright = 'FreeWare by TapirSoft Gisbert W.Selke, Feb 1990';
        secsize = 512;
        hdrlen = secsize;
        secsperblock = 120;
        bufsize = secsize * secsperblock;
        CR = #13;

  Type buf = Array [0..Pred(bufsize)] Of byte;

  Var tar, outf : File;
      tarname, outname : string;
      buffer : buf;
      dt : DateTime;
      i : byte;
      iread, ibuf, nbufs, nrest : word;
      nsecs, memberlen, datestamp : longint;
      finish : boolean;

  Function ReadKey : char;
  { don't need CRT unit for this!                                            }
    Inline(
      $B4/$08/               { Mov ah, $08 }
      $CD/$21);              { Int $21     }

  Procedure abort(msg : string; ierr : byte);
  { display an error message and die with error code                         }
  Begin                                                              { abort }
    If IOResult <> 0 Then;
    If msg <> '' Then writeln(progname,': ',msg);
    Halt(ierr);
  End;                                                               { abort }

  Procedure usage;
  { give hints on usage and die                                              }
  Begin                                                              { usage }
    writeln('A simple programme to extract all members from a TAR file');
    writeln('Usage: ',progname,' <tarfilename>');
    abort('',1);
  End;                                                               { usage }

  Procedure crackutime(datestamp : longint; Var dt : DateTime);
  { extracts date and time from Unix time stamp, assuming TZ = GMT + 8       }
    Const monlen : Array [1..12] Of byte =
                                        (31,28,31,30,31,30,31,31,30,31,30,31);
  Begin                                                         { crackutime }
    With dt Do
    Begin
      datestamp := datestamp - 8*3600;
      sec := datestamp Mod 60;
      datestamp := datestamp Div 60;
      min := datestamp Mod 60;
      datestamp := datestamp Div 60;
      hour:= datestamp Mod 24;
      datestamp := datestamp Div 24;
      year := 1970;
      While datestamp > 0 Do
      Begin
        Inc(year);
        If (year Mod 4) = 0 Then day := 366
                            Else day := 365;
        datestamp := datestamp - day;
      End;
      Dec(year);
      day := datestamp + day + 1;
      month := 1;
      While day > monlen[month] Do
      Begin
        day := day - monlen[month];
        If (month = 2) And ((year Mod 4) = 0) Then Dec(day);
        Inc(month);
      End;
    End;
  End;                                                          { crackutime }

  Procedure openfile(Var outname : string);
  { make a name acceptable for DOS and open the file for output              }

    Const badletter : Set Of char = ['.','+',' ',':','<','>','|'];
          yesset : Set Of char = ['Y','J','1'];
          noset  : Set Of char = ['N','0'];

    Var i : byte;
        ch : char;
        temp, drive, dir, name, ext : string;
        ok : boolean;

    Procedure makedirs(Var dir1 : string; dir2 : string);
    { make a directory recursively, if necessary                             }
      Var i : byte;
          dire, temp : string;
          sr : SearchRec;
    Begin                                                         { makedirs }
      If dir2 = '' Then Exit;
      i := Pos('\',dir2);
      temp := Copy(dir2,1,Pred(i));
      Delete(dir2,1,i);
      If temp[1] = '.' Then Delete(temp,1,1);
      i := Pos('.',temp);
      If i > 0 Then
      Begin
        dire := Copy(temp,Succ(i),255);
        Delete(temp,i,255);
      End
        Else dire := '';
      If Length(temp) > 8 Then
      Begin
        dire := Copy(temp,9,255);
        Delete(temp,9,255);
      End;
      If Length(dire) > 3 Then Delete(dire,4,255);
      If Pos('.',dire) > 0 Then Delete(dire,Pos('.',dire),255);
      dir1 := dir1 + temp + '.' + dire;
      FindFirst(dir1,directory,sr);
      If DosError <> 0 Then
      Begin
        MkDir(dir1);
        If IOResult <> 0 Then abort('Error making directory '+dir1,2);
      End;
      dir1 := dir1 + '\';
      makedirs(dir1,dir2);
    End;                                                          { makedirs }

    Procedure filesplit(path : string; Var drive, dir, name, ext : string);
    { splits path spec into component parts. like Borland FSplit, but        }
    { more liberal.                                                          }
      Var k : byte;
    Begin                                                        { filesplit }
      drive := '';
      dir := '';
      name := '';
      ext := '';
      If (Length(path) >= 2) And (path[2] = ':') Then
      Begin
        drive := Copy(path,1,2);
        Delete(path,1,2);
      End;
      k := Pos('\',path);
      While k > 0 Do
      Begin
        dir := dir + Copy(path,1,k);
        Delete(path,1,k);
        k := Pos('\',path);
      End;
      name := path;
      If name[1] = '.' Then Delete(name,1,1);
      k := Pos('.',name);
      If k > 0 Then
      Begin
        ext := Copy(name,k,255);
        Delete(name,k,255);
      End;
    End;                                                         { filesplit }

  Begin                                                           { openfile }
    temp := outname;
    ok := True;
    For i := Length(temp) DownTo 1 Do
    Begin
      If temp[i] = '.' Then
      Begin
        If Not ok Then temp[i] := '_';
        ok := False;
      End
      Else
      Begin
        If temp[i] = '/' Then temp[i] := '\';
        If temp[i] = '\' Then ok := True;
        If temp[i] In badletter Then temp[i] := '_';
        temp[i] := UpCase(temp[i]);
      End;
    End;
    ok := False;
    filesplit(temp,drive,dir,name,ext);
    temp := '';
    makedirs(temp,dir);
    dir := temp;
    If ext = '' Then ext := '.';
    If Length(name) > 8 Then
    Begin
      If Length(ext) = 1 Then ext := '.' + Copy(name,9,3);
      Delete(name,9,255);
    End;
    If name = '' Then
    Begin
      name := Copy(ext,2,255);
      ext := '';
    End;
    If Length(ext) > 4 Then Delete(ext,5,255);
    Repeat
      Assign(outf,dir+name+ext);
      Reset(outf,1);
      If IOResult <> 0 Then ok := True
      Else
      Begin
        Close(outf);
        write(dir+name+ext,' already exists. Overwrite? (y/n) ');
        Repeat
          ch := UpCase(ReadKey);
        Until ch In yesset + noset;
        ok := ch in yesset;
        write(CR);
      End;
      If Not ok Then
      Begin
        While Length(name) < 8 Do name := name + '0';
        i := Length(name);
        While (name[i] = '9') And (i > 1) Do
        Begin
          name[i] := '0';
          Dec(i);
        End;
        If i = 0 Then abort('Cannot fix name '+outname,3);
        If Not (name[i] In ['0'..'9']) Then name[i] := '0'
                                       Else name[i] := Succ(name[i]);
      End;
    Until ok;
    temp := dir + name + ext;
    write('Original name: ',outname,', DOS name ',temp);
    outname := temp;
    Rewrite(outf,1);
    IF IOResult <> 0 Then abort('Cannot output to file '+outname+'??',4);
  End;                                                            { openfile }

Begin                                                                 { main }
  writeln(progname,' ',version,' - extract files from a TAR');
  writeln(copyright);
  If ParamCount <> 1 Then usage;
  tarname := ParamStr(1);
  If Pos('.',tarname) = 0 Then tarname := tarname + '.TAR';
  Assign(tar,tarname);
  i := FileMode;
  FileMode := 0;
  Reset(tar,1);
  FileMode := i;
  If IOResult <> 0 Then abort('Cannot open TAR file '+tarname,4);
  finish := False;
  While Not (EoF(tar) Or finish) Do
  Begin
    BlockRead(tar,buffer,hdrlen,iread);
    If iread <> hdrlen Then abort('Illegal header in TAR file',5);
    i := 0;
    While (buffer[i] <> 0) And (i < 254) Do Inc(i);
    finish := i = 0;
    If Not finish Then
    Begin
      Move(buffer,outname[1],i);
      outname[0] := char(i);
      memberlen := 0;
      For i := $7C To $86 Do
      Begin
        If (buffer[i] >= 48) And (buffer[i] <= 55) Then
                    memberlen := 8*memberlen + buffer[i] - 48;
      End;
      If memberlen > 0 Then
      Begin
        datestamp := 0;
        For i := $88 To $92 Do
        Begin
          If (buffer[i] >= 48) And (buffer[i] <= 55) Then
                      datestamp := 8*datestamp + buffer[i] - 48;
        End;
        crackutime(datestamp,dt);
        PackTime(dt,datestamp);
        openfile(outname);
        nsecs := (memberlen + Pred(secsize)) Div secsize;
        nbufs := (nsecs + Pred(secsperblock)) Div secsperblock;
        For ibuf := 1 To Pred(nbufs) Do
        Begin
          write('.');
          BlockRead(tar,buffer,bufsize,iread);
          If iread <> bufsize Then abort('Input file too short',6);
          BlockWrite(outf,buffer,bufsize,iread);
          If iread <> bufsize Then abort('Error writing to output file',7);
        End;
        nsecs := nsecs - Pred(nbufs)*secsperblock;
        If nsecs > 0 Then
        Begin
          write('.');
          nrest := nsecs*secsize;
          BlockRead(tar,buffer,nrest,iread);
          If iread <> nrest Then abort('Input file too short',6);
          nrest := memberlen - longint(Pred(nbufs))*bufsize;
          BlockWrite(outf,buffer,nrest,iread);
          If iread <> nrest Then abort('Error writing to output file',7);
        End;
        SetFTime(outf,datestamp);
        Close(outf);
        writeln;
      End;
    End;
  End;
  Close(tar);
End.